[CM] Expose object_type_name/type-name

[chohag at jtan.com]

Patch does as described in the subject, plus fixes a typo I found
in s7.h. This i helpful to construct error messages when checking
function arguments. Did I miss anything? It seems to work OK here.

I don't know what s7_set_p_p_function does or whether I should use
something else.

Matthew

--- ../s7/s7.h	Mon Mar 30 11:33:30 2026
+++ s7.h	Mon Mar 30 11:34:15 2026
@@ -446,7 +446,7 @@
 s7_pointer s7_inlet(s7_scheme *sc, s7_pointer bindings);                    /* (inlet ...) */
 s7_pointer s7_varlet(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value); /* (varlet env symbol value) */
 s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer env);                   /* (let->list env) */
-bool s7_is_let(s7_pointer e);                                               /* )let? e) */
+bool s7_is_let(s7_pointer e);                                               /* (let? e) */
 s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer env, s7_pointer sym);       /* (let-ref e sym) */
 s7_pointer s7_let_set(s7_scheme *sc, s7_pointer env, s7_pointer sym, s7_pointer val); /* (let-set! e sym val) */
 s7_pointer s7_openlet(s7_scheme *sc, s7_pointer e);                         /* (openlet e) */
@@ -703,6 +703,7 @@
 s7_pointer s7_copy(s7_scheme *sc, s7_pointer args);            /* (copy ...) */
 s7_pointer s7_fill(s7_scheme *sc, s7_pointer args);            /* (fill! ...) */
 s7_pointer s7_type_of(s7_scheme *sc, s7_pointer arg);          /* (type-of arg) */
+s7_pointer s7_type_name(s7_scheme *sc, s7_pointer obj);        /* (type-name obj) */
 
 

--- ../s7/s7.c	Mon Mar 30 11:33:30 2026
+++ s7.c	Mon Mar 30 11:45:07 2026
@@ -1467,7 +1467,7 @@
              symbol_symbol, symbol_to_dynamic_value_symbol, symbol_initial_value_symbol,
              symbol_to_keyword_symbol, symbol_to_string_symbol, symbol_to_value_symbol,
              tan_symbol, tanh_symbol, throw_symbol, string_to_byte_vector_symbol,
-             tree_count_symbol, tree_leaves_symbol, tree_memq_symbol, tree_set_memq_symbol, tree_is_cyclic_symbol, truncate_symbol, type_of_symbol,
+             tree_count_symbol, tree_leaves_symbol, tree_memq_symbol, tree_set_memq_symbol, tree_is_cyclic_symbol, truncate_symbol, type_of_symbol, type_name_symbol,
              unlet_symbol,
              values_symbol, varlet_symbol, vector_append_symbol, vector_dimension_symbol, vector_dimensions_symbol, vector_fill_symbol,
              vector_rank_symbol, vector_ref_symbol, vector_set_symbol, vector_symbol, vector_typer_symbol,
@@ -6467,7 +6467,7 @@
   return("messed up object");
 }
 
-static s7_pointer object_type_name(s7_scheme *sc, s7_pointer obj) /* used only by the error handlers */
+static s7_pointer object_type_name(s7_scheme *sc, s7_pointer obj) /* useful for error handlers */
 {
   uint8_t typ;
   if (has_active_methods(sc, obj))
@@ -56798,7 +56798,24 @@
   /* return(sc->type_to_typers[type(car(args))]); */
 }
 
+s7_pointer s7_type_name(s7_scheme *sc, s7_pointer obj) { return object_type_name(sc, obj); }
 
+static s7_pointer g_type_name(s7_scheme *sc, s7_pointer args)
+{
+  #define H_type_name "(type-name obj) returns a string describing obj's type: (type-name 1): \"an integer\""
+  #define Q_type_name s7_make_signature(sc, 2, sc->is_string_symbol, sc->T)
+
+  s7_pointer obj = car(args), func;
+  if (!has_active_methods(sc, obj))
+    return object_type_name(sc, obj);
+  func = find_method_with_let(sc, obj, sc->type_name_symbol);
+  if (func == sc->undefined)
+    return object_type_name(sc, obj);
+  return(s7_apply_function(sc, func, set_mlist_1(sc, obj)));
+  /* return(sc->type_to_typers[type(car(args))]); */
+}
+
+
 /* -------------------------------- exit emergency-exit -------------------------------- */
 void s7_quit(s7_scheme *sc)
 {
@@ -74471,7 +74488,7 @@
 	        "random", "logior", "caaadr", "cadadr", "cdaadr", "cddadr", "lognot", "sublet", "curlet", "cutlet", "outlet",
 	      "letrec*", "complex", "unquote", "reverse", "string?", "let-ref", "gensym?", "require", "define*", "call/cc",
 	        "newline", "char<=?", "vector?", "char>=?", "funclet", "display", "rootlet", "logbit?", "lambda*", "bignum?", "provide", "symbol?",
-	        "iterate", "openlet", "ceiling", "syntax?", "type-of", "number?",
+	        "iterate", "openlet", "ceiling", "syntax?", "type-of", "type-name", "number?",
 	      "quotient", "dilambda", "complex?", "reverse!", "string<?", "set-cdr!", "set-car!", "keyword?", "defined?",
 	        "string>?", "integer?", "funclet?", "let-set!", "inexact?", "boolean?", "with-let", "openlet?", "truncate", "string=?",
 	        "list-ref", "coverlet", "for-each",
@@ -101146,6 +101163,7 @@
   s7_set_p_p_function(sc, global_value(sc->is_constant_symbol), is_constant_p_p);
   s7_set_b_7p_function(sc, global_value(sc->is_constant_symbol), is_constant_b_7p);
   s7_set_p_p_function(sc, global_value(sc->type_of_symbol), s7_type_of);
+  s7_set_p_p_function(sc, global_value(sc->type_name_symbol), s7_type_name);
   s7_set_p_i_function(sc, global_value(sc->integer_to_char_symbol), integer_to_char_p_i);
   s7_set_p_p_function(sc, global_value(sc->integer_to_char_symbol), integer_to_char_p_p);
   s7_set_p_p_function(sc, global_value(sc->iterate_symbol), iterate_p_p);
@@ -102417,6 +102435,7 @@
   sc->is_equal_symbol =              defun("equal?",		is_equal,		2, 0, false);
   sc->is_equivalent_symbol =         defun("equivalent?",	is_equivalent,	2, 0, false);
   sc->type_of_symbol =               defun("type-of",		type_of,		1, 0, false);
+  sc->type_name_symbol =             defun("type-name",		type_name,		1, 0, false);
 
   sc->gc_symbol =                    semisafe_defun("gc",	gc,			0, 1, false);
                                      defun("emergency-exit",	emergency_exit,		0, 1, false);