From a46e4c71b64fd2bb4c51eea4085bed498ca986f1 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 16 Apr 2013 09:46:04 -0500
Subject: [PATCH] fix case-> to not abuse procedure-chaperone

closes PR 13697
---
 collects/racket/contract/private/arrow.rkt |  7 ++++++-
 collects/tests/racket/contract-test.rktl   | 10 ++++++++++
 2 files changed, 16 insertions(+), 1 deletion(-)

diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt
index a07130a07e..b8f7a76fb4 100644
--- a/collects/racket/contract/private/arrow.rkt
+++ b/collects/racket/contract/private/arrow.rkt
@@ -1561,7 +1561,12 @@ v4 todo:
            (this-parameter ... dom-formals ... . #,(if rst #'rst-formal '()))
            #,(cond
                [rng
-                (let ([rng-checkers (list #'(λ (rng-id ...) (values/drop (rng-proj-x rng-id) ...)))]
+                (let ([rng-checkers (list #`(case-lambda
+                                              [(rng-id ...) (values/drop (rng-proj-x rng-id) ...)]
+                                              [args 
+                                               (bad-number-of-results blame f 
+                                                                      #,(length (syntax->list #'(rng-id ...)))
+                                                                      args)]))]
                       [rng-length (length (syntax->list rng))])
                   (if rst
                       (check-tail-contract #'(rng-proj-x ...) rng-checkers
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index ee4a95b7a6..82ef0387b3 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -3577,6 +3577,16 @@
             (f 1)
             (f 'x (open-input-string (format "~s" "string")))))
    (list #\a #f "xstring"))
+  
+  (test/pos-blame
+   'contract-case->15
+   '((contract (case-> (-> real? real? real?)
+                       (-> real? (values real? real?)))
+               (case-lambda
+                 [(x y) 1]
+                 [(x) 1])
+               'pos 'neg)
+     1))
 
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;                                                        ;;