procedure-rename special treatment of struct accessors & mutators

svn: r17093

collects/scribblings/reference/procedures.scrbl

@@ -53,8 +53,18 @@ result is @scheme[values].
 
 Returns a procedure that is like @scheme[proc], except that its name
 as returned by @scheme[object-name] (and as printed for debugging) is
-@scheme[name].}
+@scheme[name].
 
+The given @scheme[name] is used for printing an error message if the
+resulting procedure is applied to the wrong number of arguments.  In
+addition, if @scheme[proc] is an @tech{accessor} or @tech{mutator}
+produced by @scheme[define-struct],
+@scheme[make-struct-field-accessor], or
+@scheme[make-struct-field-mutator], the resulting procedure also uses
+@scheme[name] when its (first) argument has the wrong type. More
+typically, however, @scheme[name] is not used for reporting errors,
+since the procedure name is typically hard-wired into an internal
+check.}
 
 @; ----------------------------------------
 @section{Keywords and Arity}

src/mzscheme/src/fun.c

@@ -3661,13 +3661,16 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
 
 static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[])
 {
-  Scheme_Object *aty;
+  Scheme_Object *p, *aty;
 
   if (!SCHEME_PROCP(argv[0]))
     scheme_wrong_type("procedure-rename", "procedure", 0, argc, argv);
   if (!SCHEME_SYMBOLP(argv[1]))
     scheme_wrong_type("procedure-rename", "symbol", 1, argc, argv);
 
+  p = scheme_rename_struct_proc(argv[0], argv[1]);
+  if (p) return p;
+
   aty = get_or_check_arity(argv[0], -1, NULL);  
 
   return make_reduced_proc(argv[0], aty, argv[1]);

src/mzscheme/src/schpriv.h

@@ -689,6 +689,8 @@ Scheme_Object *scheme_clone_prefab_struct_instance(Scheme_Structure *s);
 
 Scheme_Object *scheme_extract_checked_procedure(int argc, Scheme_Object **argv);
 
+Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym);
+
 /*========================================================================*/
 /*                         syntax objects                                 */
 /*========================================================================*/

src/mzscheme/src/struct.c

@@ -2779,6 +2779,29 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
   return p;
 }
 
+Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym)
+{
+  if (SCHEME_PRIMP(p)) {
+    int is_getter = (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER);
+    int is_setter = (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER);
+    
+    if (is_getter || is_setter) {
+      const char *func_name;
+      Struct_Proc_Info *i;
+
+      func_name = scheme_symbol_name(sym);
+      
+      i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(p)[0];
+      
+      return make_struct_proc(i->struct_type, (char *)func_name, 
+                              is_getter ? SCHEME_GETTER : SCHEME_SETTER,
+                              i->field);
+    }
+  }
+
+  return NULL;
+}
+
 static Scheme_Object *make_name(const char *pre, const char *tn, int ltn,
 				const char *post1, const char *fn, int lfn,
 				const char *post2, int sym)