From 4632899b816d599aabf69a819b830a75ccf6e388 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 6 Apr 2013 14:07:48 -0500
Subject: [PATCH] get a better name for certain contract error messages

related to PR 13665
---
 collects/racket/contract/private/arrow.rkt | 9 +++++++--
 1 file changed, 7 insertions(+), 2 deletions(-)

diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt
index 0dae3e7113..2db2edb945 100644
--- a/collects/racket/contract/private/arrow.rkt
+++ b/collects/racket/contract/private/arrow.rkt
@@ -1593,7 +1593,8 @@ v4 todo:
 (define-syntax (case-> stx)
   (syntax-case stx ()
     [(_ cases ...)
-     (begin 
+     (let ()
+       (define name (syntax-local-infer-name stx))
        (with-syntax ([(((dom-proj ...)
                         rst-proj
                         rng-proj
@@ -1624,7 +1625,11 @@ v4 todo:
                                       (λ (kwds kwd-args . args)
                                         (raise-blame-error blame f "expected no keywords, got keyword ~a" (car kwds)))
                                       (λ args
-                                        (apply (case-lambda [formals body] ...) args)))]
+                                        (apply #,(let ([case-lam (syntax/loc stx (case-lambda [formals body] ...))])
+                                                   (if name 
+                                                       #`(let ([#,name #,case-lam]) #,name)
+                                                       case-lam))
+                                               args)))]
                                     [same-rngs (same-range-projections (list (list rng-proj-x ...) ...))])
                                 (if same-rngs
                                     (wrapper