Add prop:object-name.

pkgs/racket-doc/scribblings/reference/struct-inspectors.scrbl

@@ -149,13 +149,16 @@ The name (if any) of a procedure is always a symbol. The
 @racket[procedure-rename] function creates a procedure with a specific
 name.
 
-The name of a @tech{structure}, @tech{structure type}, @tech{structure
-type property} is always a symbol. If a @tech{structure} is a
-procedure as implemented by one of its fields (i.e., the
-@racket[prop:procedure] property value for the structure's type is an
-integer), then its name is the implementing procedure's name;
-otherwise, its name matches the name of the @tech{structure type} that
-it instantiates.
+If a @tech{structure}'s type implements the @racket[prop:object-name] property,
+and the value of the @racket[prop:object-name] property is an integer, then the
+corresponding field of the structure is the name of the structure.
+Otherwise, the property value must be a procedure, which is called with the
+structure as argument, and the result is the name of the structure.
+If a @tech{structure} is a procedure as implemented by one of its
+fields (i.e., the @racket[prop:procedure] property value for the structure's
+type is an integer), then its name is the implementing procedure's name.
+Otherwise, its name matches the name of the @tech{structure type} that it
+instantiates.
 
 The name of a @tech{regexp value} is a string or byte string. Passing
 the string or byte string to @racket[regexp], @racket[byte-regexp],
@@ -169,3 +172,22 @@ example).
 
 The name of a @tech{logger} is either a symbol or @racket[#f].}
 
+@defthing[prop:object-name struct-type-property?]{
+
+A @tech{structure type property} that allows structure types to customize
+ the result of @racket[object-name] applied to their instances. The property value can
+ be any of the following:
+
+@itemize[
+ @item{A procedure @racket[_proc] of one argument: In this case, 
+ procedure @racket[_proc] receives the structure as an argument, and the result
+ of @racket[_proc] is the @racket[object-name] of the structure.}
+
+ @item{An exact, non-negative integer between @racket[0] (inclusive) and the
+ number of non-automatic fields in the structure type (exclusive, not counting
+ supertype fields): The integer identifies a field in the structure, and the
+ field must be designated as immutable. The value of the field is used as the
+ @racket[object-name] of the structure.}
+]
+@history[#:added "6.2.0.2"]
+}

pkgs/racket-test-core/tests/racket/struct.rktl

@@ -1100,6 +1100,25 @@
     (set! f (lambda () (thing.id! (make-thing 1) 'new-val)))
     (err/rt-test (f))))
 
+;; ----------------------------------------
+;; Test `prop:object-name`:
+
+(let ()
+  (struct x1 (v) #:property prop:object-name 0)
+  (struct x2 (v) #:property prop:object-name
+          (lambda (s) 'name))
+  (struct x3 (v) #:property prop:object-name
+          (lambda (s) (x3-v s)))
+  (test 'x object-name (x1 'x))
+  (test 'name object-name (x2 'x))
+  (test "x" object-name (x3 "x"))
+  (err/rt-test (let () (struct x1 (v) #:property prop:object-name 1) 0))
+  (err/rt-test (let () (struct x0 (w)) (struct x1 x0 () #:property prop:object-name 0) 0))
+  (err/rt-test (let () (struct x1 (v) #:property prop:object-name (lambda () 0)) 0))
+  (err/rt-test (let () (struct x1 (v) #:property prop:object-name (lambda (a b) 0)) 0))
+  (err/rt-test (let () (struct x1 (v) #:mutable #:property prop:object-name 0) 0)))
+
+
 ;; ----------------------------------------
 ;; Check interaction of `struct-type-info` and GC:
 

racket/src/racket/src/fun.c

@@ -2865,6 +2865,23 @@ static Scheme_Object *primitive_result_arity(int argc, Scheme_Object *argv[])
 
 Scheme_Object *scheme_object_name(Scheme_Object *a)
 {
+  Scheme_Object *v;
+
+  v = scheme_struct_type_property_ref(scheme_object_name_property, a);
+
+  if (v) {
+    if (SCHEME_INTP(v))
+      return scheme_struct_ref(a, SCHEME_INT_VAL(v));
+    if (SCHEME_PROCP(v)) {
+      if (scheme_check_proc_arity(NULL, 1, 0, 1, &v)) {
+        Scheme_Object *f = v, *arg[1];
+        
+        arg[0] = a;
+        return scheme_apply(f, 1, arg);
+      }
+    }
+  }
+
   if (SCHEME_CHAPERONEP(a))
     a = SCHEME_CHAPERONE_VAL(a);
 

racket/src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1130
+#define EXPECTED_PRIM_COUNT 1131
 #define EXPECTED_UNSAFE_COUNT 106
 #define EXPECTED_FLFXNUM_COUNT 69
 #define EXPECTED_EXTFL_COUNT 45

racket/src/racket/src/schpriv.h

@@ -529,6 +529,7 @@ extern Scheme_Object *scheme_input_port_property, *scheme_output_port_property;
 extern Scheme_Object *scheme_cpointer_property;
 
 extern Scheme_Object *scheme_equal_property;
+extern Scheme_Object *scheme_object_name_property;
 extern Scheme_Object *scheme_impersonator_of_property;
 
 extern Scheme_Object *scheme_app_mark_impersonator_property;

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "6.2.0.1"
+#define MZSCHEME_VERSION "6.2.0.2"
 
 #define MZSCHEME_VERSION_X 6
 #define MZSCHEME_VERSION_Y 2
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 1
+#define MZSCHEME_VERSION_W 2
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

racket/src/racket/src/struct.c

@@ -47,6 +47,7 @@ READ_ONLY Scheme_Object *scheme_display_symbol;
 READ_ONLY Scheme_Object *scheme_write_special_symbol;
 READ_ONLY Scheme_Object *scheme_app_mark_impersonator_property;
 READ_ONLY Scheme_Object *scheme_liberal_def_ctx_type;;
+READ_ONLY Scheme_Object *scheme_object_name_property;
 
 READ_ONLY static Scheme_Object *location_struct;
 READ_ONLY static Scheme_Object *write_property;
@@ -105,6 +106,7 @@ static Scheme_Object *make_struct_type_property_from_c(int argc, Scheme_Object *
 static Scheme_Object *struct_type_property_p(int argc, Scheme_Object *argv[]);
 static Scheme_Object *chaperone_property_p(int argc, Scheme_Object *argv[]);
 static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[]);
+static Scheme_Object *check_object_name_property_value_ok(int argc, Scheme_Object *argv[]);
 static Scheme_Object *check_equal_property_value_ok(int argc, Scheme_Object *argv[]);
 static Scheme_Object *check_impersonator_of_property_value_ok(int argc, Scheme_Object *argv[]);
 static Scheme_Object *check_write_property_value_ok(int argc, Scheme_Object *argv[]);
@@ -396,6 +398,16 @@ scheme_init_struct (Scheme_Env *env)
     scheme_add_global_constant("prop:procedure", proc_property, env);
   }
 
+  {
+    REGISTER_SO(scheme_object_name_property);
+    guard = scheme_make_prim_w_arity(check_object_name_property_value_ok,
+				     "guard-for-prop:object-name",
+				     2, 2);
+    scheme_object_name_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("object-name"),
+                                                                           guard);
+    scheme_add_global_constant("prop:object-name", scheme_object_name_property, env);
+  }
+
   {
     REGISTER_SO(scheme_no_arity_property);
     scheme_no_arity_property = scheme_make_struct_type_property(scheme_intern_symbol("incomplete-arity"));
@@ -1645,6 +1657,28 @@ static int is_evt_struct(Scheme_Object *o)
   return 0;
 }
 
+
+/*========================================================================*/
+/*                            object-name structs                         */
+/*========================================================================*/
+/* This is here so it can use check_indirect_property_value_ok */
+
+static int is_proc_1(Scheme_Object *o) { return (SCHEME_PROCP(o) && scheme_check_proc_arity(NULL, 1, -1, 0, &o)); }
+static int is_proc_1_or_2(Scheme_Object *o) { return (SCHEME_PROCP(o) && (scheme_check_proc_arity(NULL, 1, -1, 0, &o)
+                                                                          || scheme_check_proc_arity(NULL, 2, -1, 0, &o))); }
+
+
+
+static Scheme_Object *check_object_name_property_value_ok(int argc, Scheme_Object *argv[])
+/* This is the guard for prop:object-name */
+{
+  return check_indirect_property_value_ok("guard-for-prop:object-name",
+                                          is_proc_1, 1,
+                                          "(or/c (any/c . -> . any) exact-nonnegative-integer?)",
+                                          argc, argv);
+}
+
+
 /*========================================================================*/
 /*                            port structs                                */
 /*========================================================================*/
@@ -1866,10 +1900,6 @@ int scheme_is_set_transformer(Scheme_Object *o)
   return 0;
 }
 
-static int is_proc_1(Scheme_Object *o) { return (SCHEME_PROCP(o) && scheme_check_proc_arity(NULL, 1, -1, 0, &o)); } 
-static int is_proc_1_or_2(Scheme_Object *o) { return (SCHEME_PROCP(o) && (scheme_check_proc_arity(NULL, 1, -1, 0, &o)
-                                                                          || scheme_check_proc_arity(NULL, 2, -1, 0, &o))); }
-
 Scheme_Object *signal_bad_syntax(int argc, Scheme_Object **argv)
 {
   scheme_wrong_syntax(NULL, NULL, argv[0], "bad syntax");