Generalize inferred names

After some expansions, a expression with the syntax property 'inferred-name of
'x is converted to one with ('x . 'x), so it's not useful to get the name of a
procedure. So we simplify the syntax property 'inferred-name to handle
these cases.

pkgs/racket-doc/scribblings/reference/syntax-model.scrbl

@@ -1101,6 +1101,13 @@ property value of @|void-const| hides a name that would otherwise be
 inferred from context (perhaps because a binding identifier's was 
 automatically generated and should not be exposed).
 
+To support the propagation and merging of consistent properties during
+expansions, the value of the @racket['inferred-name] property can be a
+tree formed with @racket[cons] where all of the leaves are the same.
+For example, @racket[(cons 'name 'name)] is equivalent to
+@racket['name], and @racket[(cons (void) (void))] is equivalent to
+@|void-const|.
+
 When an inferred name is not available, but a source location is
 available, a name is constructed using the source location
 information. Inferred and property-assigned names are also available

pkgs/racket-doc/syntax/scribblings/name.scrbl

@@ -8,13 +8,21 @@
 @defproc[(syntax-local-infer-name [stx syntax?] [use-local? any/c #t]) any/c]{
 
 Similar to @racket[syntax-local-name], except that @racket[stx] is
-checked for an @racket['inferred-name] property (which overrides any
+checked for an @racket['inferred-name] property that is a symbol
-inferred name). If neither @racket[syntax-local-name] nor
+(which overrides any inferred name) or @|void-const|.
+If neither @racket[syntax-local-name] nor
 @racket['inferred-name] produce a name, or if the
 @racket['inferred-name] property value is @|void-const|, then a name
 is constructed from the source-location information in @racket[stx],
 if any. If no name can be constructed, the result is @racket[#f].
 
+To support the propagation and merging of consistent properties during
+expansions, the value of the @racket['inferred-name] property can be a
+tree formed with @racket[cons] where all of the leaves are the same.
+For example, @racket[(cons 'name 'name)] is equivalent to
+@racket['name], and @racket[(cons (void) (void))] is equivalent to
+@|void-const|.
+
 If @racket[use-local?] is @racket[#f], then @racket[syntax-local-name] is
 not used. Provide @racket[use-local?] as @racket[#f] to construct a name
 for a syntax object that is not an expression currently being expanded.}

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

@@ -3,8 +3,8 @@
 
 (load-relative "loadtest.rktl")
 
-(require scheme/class)
+(require racket/class)
-(require scheme/unit)
+(require racket/unit)
 
 (Section 'names)
 
@@ -134,6 +134,23 @@
                    5))
              #rx"^(?!.*unmentionable)")
 
+;; Test use of the 'inferred-name syntax property
+(define-syntax (named-thunk1 stx)
+  (syntax-case stx ()
+    [(_ v)
+     (syntax-property #'(lambda () 1) 'inferred-name (eval #'v))]))
+
+(test 'one object-name (let ([tmp (named-thunk1 'one)]) tmp))
+(test #t src-name? (object-name (let ([tmp (named-thunk1 (void))]) tmp)))
+(test 'tmp object-name (let ([tmp (named-thunk1 #f)]) tmp))
+(test 'tmp object-name (let ([tmp (named-thunk1 1)]) tmp))
+(test 'tmp object-name (let ([tmp (named-thunk1 "one")]) tmp))
+
+(test 'one object-name (let ([tmp (named-thunk1 (cons 'one 'one))]) tmp))
+(test #t src-name? (object-name (let ([tmp (named-thunk1 (cons (void) (void)))]) tmp)))
+(test 'tmp object-name (let ([tmp (named-thunk1 (cons #f #f))]) tmp))
+(test 'tmp object-name (let ([tmp (named-thunk1 (cons 1 1))]) tmp))
+(test 'tmp object-name (let ([tmp (named-thunk1 (cons "one" "one"))]) tmp))
 
 (test 'norm values
       (let-syntax ([m (lambda (stx)

racket/collects/racket/private/name.rkt

@@ -2,13 +2,12 @@
 (module name '#%kernel
   (#%require "define.rkt" "small-scheme.rkt")
   (#%provide syntax-local-infer-name)
-  
+
   (define syntax-local-infer-name
     (case-lambda
      [(stx use-local?)
-      (let-values ([(prop) (syntax-property stx 'inferred-name)])
+      (let-values ([(prop) (simplify-inferred-name (syntax-property stx 'inferred-name))])
-        (or (and prop
+        (or (and (symbol? prop)
-                 (not (void? prop))
                  prop)
             (let ([n (and use-local?
                           (not (void? prop))
@@ -33,4 +32,13 @@
                                (string->symbol (format "~a:~a:~a" s l c))
                                (let ([p (syntax-position stx)])
                                  (string->symbol (format "~a::~a" s p)))))))))))]
-     [(stx) (syntax-local-infer-name stx #t)])))
+     [(stx) (syntax-local-infer-name stx #t)]))
+  
+  (define (simplify-inferred-name name)
+    (if (pair? name)
+        (let ([name-car (simplify-inferred-name (car name))]
+              [name-cdr (simplify-inferred-name (cdr name))])
+          (if (eq? name-car name-cdr)
+              name-car
+              name))
+        name)))

racket/src/racket/src/compile.c

@@ -383,11 +383,49 @@ static void bad_form(Scheme_Object *form, int l)
 		      l - 1, (l != 2) ? "s" : "");
 }
 
+static Scheme_Object *simplify_inferred_name(Scheme_Object *name);
+
+static Scheme_Object *simplify_inferred_name_k(void)
+{
+  Scheme_Thread *p = scheme_current_thread;
+  Scheme_Object *name = (Scheme_Object *)p->ku.k.p1;
+
+  p->ku.k.p1 = NULL;
+
+  return (void *)simplify_inferred_name(name);
+}
+
+
+static Scheme_Object *simplify_inferred_name(Scheme_Object *name)
+{
+  {
+# include "mzstkchk.h"
+    {
+      Scheme_Thread *p = scheme_current_thread;
+
+      p->ku.k.p1 = (void *)name;
+
+      return scheme_handle_stack_overflow(simplify_inferred_name_k);
+    }
+  }
+
+  if (SCHEME_PAIRP(name)) {
+    Scheme_Object *name_car = SCHEME_CAR(name), *name_cdr = SCHEME_CDR(name);
+    name_car = simplify_inferred_name(name_car);
+    name_cdr = simplify_inferred_name(name_cdr);
+    if (SAME_OBJ(name_car, name_cdr))
+      return name_car;
+  }
+
+  return name;
+}
+
 Scheme_Object *scheme_check_name_property(Scheme_Object *code, Scheme_Object *current_val)
 {
   Scheme_Object *name;
 
   name = scheme_stx_property(code, inferred_name_symbol, NULL);
+  name = simplify_inferred_name(name);
   if (name && SCHEME_SYMBOLP(name))
     return name;
   else
@@ -551,6 +589,7 @@ Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Comp_Env *e
   Scheme_Object *name;
 
   name = scheme_stx_property(code, inferred_name_symbol, NULL);
+  name = simplify_inferred_name(name);
   if (name && SCHEME_SYMBOLP(name)) {
     name = combine_name_with_srcloc(name, code, 0);
   } else if (name && SCHEME_VOIDP(name)) {