diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl index 1332e6707e..7d5063cfdd 100644 --- a/collects/scribblings/reference/procedures.scrbl +++ b/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} diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index 6354dbaeb0..da5af9f491 100644 --- a/src/mzscheme/src/fun.c +++ b/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]); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 5c4c3b6989..ae18b4d728 100644 --- a/src/mzscheme/src/schpriv.h +++ b/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 */ /*========================================================================*/ diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index 922ee76e37..3499e7c5b6 100644 --- a/src/mzscheme/src/struct.c +++ b/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)