From 5be429dc993e05b5c271d0b38f1dce874934e070 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 13 Aug 2011 08:19:02 -0600
Subject: [PATCH] fix procedure-name inference for keyword procedures

Closes PR 12111
---
 collects/racket/private/kw.rkt   | 10 +++++++---
 collects/tests/racket/procs.rktl | 10 ++++++++++
 2 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/collects/racket/private/kw.rkt b/collects/racket/private/kw.rkt
index ea9e0fe361..6955d5eba2 100644
--- a/collects/racket/private/kw.rkt
+++ b/collects/racket/private/kw.rkt
@@ -358,7 +358,7 @@
             #f "bad argument sequence" stx (syntax args))]))))
   
   ;; The new `lambda' form:
-  (define-for-syntax (parse-lambda stx non-kw-k kw-k)
+  (define-for-syntax (parse-lambda stx local-name non-kw-k kw-k)
     (syntax-case stx ()
       [(_ args body1 body ...)
        (if (simple-args? #'args)
@@ -531,7 +531,8 @@
                       (mk-unpack)
                       (with-syntax ([kws (map car sorted-kws)]
                                     [no-kws (let ([p (mk-no-kws #t)]
-                                                  [n (syntax-local-infer-name stx)])
+                                                  [n (or local-name
+                                                         (syntax-local-infer-name stx))])
                                               (if n
                                                   #`(let ([#,n #,p]) #,n)
                                                   p))]
@@ -555,7 +556,8 @@
                                     [needed-kws needed-kws]
                                     [no-kws (mk-no-kws #t)]
                                     [with-kws (mk-with-kws)]
-                                    [mk-id (with-syntax ([n (syntax-local-infer-name stx)]
+                                    [mk-id (with-syntax ([n (or local-name
+                                                                (syntax-local-infer-name stx))]
                                                          [call-fail (mk-kw-arity-stub)])
                                              (syntax-local-lift-expression
                                               #'(make-required 'n call-fail method? #F)))])
@@ -574,6 +576,7 @@
              (if (eq? (syntax-local-context) 'expression)
                  (parse-lambda
                   stx
+                  #f
                   (lambda (e) e)
                   (lambda (impl kwimpl wrap core-id unpack-id n-req n-opt rest? req-kws all-kws)
                     (syntax-protect
@@ -796,6 +799,7 @@
                 (or (free-identifier=? #'lam-id #'new-lambda)
                     (free-identifier=? #'lam-id #'new-λ)))
            (parse-lambda rhs
+                         id
                          plain
                          (lambda (impl kwimpl wrap 
                                        core-id unpack-id
diff --git a/collects/tests/racket/procs.rktl b/collects/tests/racket/procs.rktl
index 4eff6c8c32..9a53948746 100644
--- a/collects/tests/racket/procs.rktl
+++ b/collects/tests/racket/procs.rktl
@@ -283,6 +283,16 @@
   (test 7 (lambda () (f #:x 7)))
   (set! f #f))
 
+;; ----------------------------------------
+;; Check mutation of direct-called keyword procedure
+
+(let ()
+  (define (f1 #:x x) (list x))
+  (test 'f1 object-name f1))
+(let ()
+  (define (f2 #:x [x 8]) (list x))
+  (test 'f2 object-name f2))
+
 ;; ----------------------------------------
 
 (report-errs)