diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss
index dcc9546366..d75aae073f 100644
--- a/collects/scheme/private/sort.ss
+++ b/collects/scheme/private/sort.ss
@@ -4,23 +4,26 @@
 
 (#%provide sort)
 
-;; This is a destructive stable merge-sort, adapted from slib and improved by
-;; Eli Barzilay.
-;; The original source said:
-;;   It uses a version of merge-sort invented, to the best of my knowledge, by
-;;   David H. D. Warren, and first used in the DEC-10 Prolog system.
-;;   R. A. O'Keefe adapted it to work destructively in Scheme.
-;; but it's a plain destructive merge sort, which I optimized further.
+#|
 
-;; The source uses macros to optimize some common cases (eg, no `getkey'
-;; function, or precompiled versions with inlinable common comparison
-;; predicates) -- they are local macros so they're not left in the compiled
-;; code.
+Based on "Fast mergesort implementation based on half-copying merge algorithm",
+Cezary Juszczak, http://kicia.ift.uni.wroc.pl/algorytmy/mergesortpaper.pdf
+Written in Scheme by Eli Barzilay.  (Note: the reason for the seemingly
+redundant pointer arithmetic in that paper is dealing with cases of uneven
+number of elements.)
+
+The source uses macros to optimize some common cases (eg, no `getkey'
+function, or precompiled versions with inlinable common comparison
+predicates) -- they are local macros so they're not left in the compiled
+code.
+
+Note that there is no error checking on the arguments -- the `sort' function
+that this module provide is then wrapped up by a keyworded version in
+"scheme/private/list.ss", and that's what everybody sees.  The wrapper is
+doing these checks.
+
+|#
 
-;; Note that there is no error checking on the arguments -- the `sort' function
-;; that this module provide is then wrapped up by a keyworded version in
-;; "scheme/private/list.ss", and that's what everybody sees.  The wrapper is
-;; doing these checks.
 
 (define sort (let ()
 
@@ -29,80 +32,57 @@
     [(dr (foo . pattern) template)
      (define-syntax foo (syntax-rules () [(_ . pattern) template]))]))
 
-(define-syntax-rule (sort-internal-body lst *less? n has-getkey? getkey)
+(define-syntax-rule (sort-internal-body v *<? n has-getkey? getkey)
   (begin
-    (define-syntax-rule (less? x y)
-      (if has-getkey? (*less? (getkey x) (getkey y)) (*less? x y)))
-    (define (merge-sorted! a b)
-      ;; r-a? for optimization -- is r connected to a?
-      (define (loop r a b r-a?)
-        (if (less? (mcar b) (mcar a))
-          (begin
-            (when r-a? (set-mcdr! r b))
-            (if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f)))
-          ;; (car a) <= (car b)
-          (begin
-            (unless r-a? (set-mcdr! r a))
-            (if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t)))))
-      (cond [(null? a) b]
-            [(null? b) a]
-            [(less? (mcar b) (mcar a))
-             (if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f))
-             b]
-            [else ; (car a) <= (car b)
-             (if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t))
-             a]))
-    (let step ([n n])
-      (cond [(> n 3)
-             (let* (; let* not really needed with mzscheme's l->r eval
-                    [j (quotient n 2)] [a (step j)] [b (step (- n j))])
-               (merge-sorted! a b))]
-            ;; the following two cases are just explicit treatment of sublists
-            ;; of length 2 and 3, could remove both (and use the above case for
-            ;; n>1) and it would still work, except a little slower
-            [(= n 3) (let ([p lst] [p1 (mcdr lst)] [p2 (mcdr (mcdr lst))])
-                       (let ([x (mcar p)] [y (mcar p1)] [z (mcar p2)])
-                         (set! lst (mcdr p2))
-                         (cond [(less? y x) ; y x
-                                (cond [(less? z y) ; z y x
-                                       (set-mcar! p  z)
-                                       (set-mcar! p1 y)
-                                       (set-mcar! p2 x)]
-                                      [(less? z x) ; y z x
-                                       (set-mcar! p  y)
-                                       (set-mcar! p1 z)
-                                       (set-mcar! p2 x)]
-                                      [else ; y x z
-                                       (set-mcar! p  y)
-                                       (set-mcar! p1 x)])]
-                               [(less? z x) ; z x y
-                                (set-mcar! p  z)
-                                (set-mcar! p1 x)
-                                (set-mcar! p2 y)]
-                               [(less? z y) ; x z y
-                                (set-mcar! p1 z)
-                                (set-mcar! p2 y)])
-                         (set-mcdr! p2 '())
-                         p))]
-            [(= n 2) (let ([x (mcar lst)] [y (mcar (mcdr lst))] [p lst])
-                       (set! lst (mcdr (mcdr lst)))
-                       (when (less? y x)
-                         (set-mcar! p y)
-                         (set-mcar! (mcdr p) x))
-                       (set-mcdr! (mcdr p) '())
-                       p)]
-            [(= n 1) (let ([p lst])
-                       (set! lst (mcdr lst))
-                       (set-mcdr! p '())
-                       p)]
-            [else '()]))))
+    (define-syntax-rule (<? x y)
+      (if has-getkey? (*<? (getkey x) (getkey y)) (*<? x y)))
+    (define-syntax-rule (ref n) (vector-ref v n))
+    (define-syntax-rule (set! n x) (vector-set! v n x))
+
+    (define (merge1 A1 A2 B1 B2 C1 C2)
+      (when (< C1 B1)
+        (if (< B1 B2)
+          (if (<? (ref B1) (ref A1))
+            (begin (set! C1 (ref B1))
+                   (merge1 A1 A2 (add1 B1) B2 (add1 C1) C2))
+            (begin (set! C1 (ref A1))
+                   (merge1 (add1 A1) A2 B1 B2 (add1 C1) C2)))
+          (begin (set! C1 (ref A1))
+                 (merge1 (add1 A1) A2 B1 B2 (add1 C1) C2)))))
+    (define (merge2 A1 A2 B1 B2 C1 C2)
+      (when (< C1 B1)
+        (if (< B1 B2)
+          (if (<? (ref A1) (ref B1))
+            (begin (set! C1 (ref A1))
+                   (merge2 (add1 A1) A2 B1 B2 (add1 C1) C2))
+            (begin (set! C1 (ref B1))
+                   (merge2 A1 A2 (add1 B1) B2 (add1 C1) C2)))
+          (begin (set! C1 (ref A1))
+                 (merge2 (add1 A1) A2 B1 B2 (add1 C1) C2)))))
+
+    (define (copying-mergesort Alo Ahi Blo Bhi)
+      (cond [(< Alo (sub1 Ahi))
+             (let ([Amid (/ (+ Alo Ahi) 2)] [Bmid (/ (+ Blo Bhi) 2)])
+               (copying-mergesort Amid Ahi Bmid Bhi)
+               (copying-mergesort Alo Amid Amid Ahi)
+               (merge1 Amid Ahi Bmid Bhi Blo Bhi))]
+            [(= Alo (sub1 Ahi))
+             (set! Blo (ref Alo))]))
+
+    (define (mergesort Alo Ahi B1lo B1hi)
+      (let ([Amid (/ (+ Alo Ahi) 2)])
+        (copying-mergesort Amid Ahi B1lo B1hi)
+        (copying-mergesort Alo Amid Amid Ahi)
+        (merge2 B1lo B1hi Amid Ahi Alo Ahi)))
+
+    (mergesort 0 n n (+ n (/ n 2)))))
 
 (define sort-internals (make-hasheq))
 (define _
   (let ()
-    (define-syntax-rule (precomp less? more ...)
-      (let ([proc (lambda (lst n) (sort-internal-body lst less? n #f #f))])
-        (hash-set! sort-internals less? proc)
+    (define-syntax-rule (precomp <? more ...)
+      (let ([proc (lambda (vec n) (sort-internal-body vec <? n #f #f))])
+        (hash-set! sort-internals <? proc)
         (hash-set! sort-internals more proc) ...))
     (precomp < <=)
     (precomp > >=)
@@ -112,44 +92,47 @@
 
 (define sort-internal
   (case-lambda
-    [(less? lst n)
-     (let ([si (hash-ref sort-internals less? #f)])
+    [(<? vec n)
+     (let ([si (hash-ref sort-internals <? #f)])
        (if si
          ;; use a precompiled function if found
-         (si lst n)
+         (si vec n)
          ;; otherwise, use the generic code
-         (let () (sort-internal-body lst less? n #f #f))))]
-    [(less? lst n getkey)
-     (sort-internal-body lst less? n #t getkey)]))
+         (let () (sort-internal-body vec <? n #f #f))))]
+    [(<? vec n getkey)
+     (let () (sort-internal-body vec <? n #t getkey))]))
 
-(define-syntax-rule (sort-body lst *less? has-getkey? getkey cache-keys?)
+(define-syntax-rule (sort-body lst *<? has-getkey? getkey cache-keys?)
   (let ([n (length lst)])
-    (define-syntax-rule (less? x y)
-      (if has-getkey? (*less? (getkey x) (getkey y)) (*less? x y)))
+    (define-syntax-rule (<? x y)
+      (if has-getkey? (*<? (getkey x) (getkey y)) (*<? x y)))
     (cond
       ;; trivial case
       [(= n 0) lst]
       ;; below we can assume a non-empty input list
       [cache-keys?
-       ;; decorate while converting to an mlist, and undecorate when going
+       ;; decorate while converting to a vector, and undecorate when going
        ;; back, always do this for consistency
-       (let (;; list -> decorated-mlist
-             [mlst (let ([x (car lst)]) (mcons (cons (getkey x) x) null))])
-         (let loop ([last mlst] [lst (cdr lst)])
+       (let ([vec (make-vector (+ n (/ n 2)))])
+         ;; list -> decorated-vector
+         (let loop ([i 0] [lst lst])
            (when (pair? lst)
-             (let ([new (let ([x (car lst)]) (mcons (cons (getkey x) x) null))])
-               (set-mcdr! last new)
-               (loop new (cdr lst)))))
-         ;; decorated-mlist -> list
-         (let loop ([r (sort-internal *less? mlst n car)])
-           (if (null? r) r (cons (cdr (mcar r)) (loop (mcdr r))))))]
+             (let ([x (car lst)])
+               (vector-set! vec i (cons (getkey x) x))
+               (loop (add1 i) (cdr lst)))))
+         ;; sort
+         (sort-internal *<? vec n car)
+         ;; decorated-vector -> list
+         (let loop ([i n] [r '()])
+           (let ([i (sub1 i)])
+             (if (< i 0) r (loop i (cons (cdr (vector-ref vec i)) r))))))]
       ;; trivial cases
       [(< n 2) lst]
       ;; check if the list is already sorted (which can be common, eg,
       ;; directory lists)
       [(let loop ([last (car lst)] [next (cdr lst)])
          (or (null? next)
-             (and (not (less? (car next) last))
+             (and (not (<? (car next) last))
                   (loop (car next) (cdr next)))))
        lst]
       ;; below we can assume an unsorted list
@@ -161,43 +144,45 @@
          (list (cadr lst) (car lst))
          (let ([a (car lst)] [b (cadr lst)] [c (caddr lst)])
            ;; General note: we need a stable sort, so we should always compare
-           ;; (less? later-item earlier-item) since it gives more information.
-           ;; A good way to see that we have good code is to check that each
+           ;; (<? later-item earlier-item) since it gives more information.  A
+           ;; good way to see that we have good code is to check that each
            ;; permutation appears exactly once.  This means that n=4 will have
            ;; 23 cases, so don't bother.  (Homework: write a macro to generate
            ;; code for a specific N.  Bonus: prove correctness.  Extra bonus:
            ;; prove optimal solution.  Extra extra bonus: prove optimal
            ;; solution exists, extract macro from proof.)
            (let ([a (car lst)] [b (cadr lst)] [c (caddr lst)])
-             (if (less? b a)
+             (if (<? b a)
                ;; b<a
-               (if (less? c b)
+               (if (<? c b)
                  (list c b a)
                  ;; b<a, b<=c
-                 (if (less? c a) (list b c a) (list b a c)))
+                 (if (<? c a) (list b c a) (list b a c)))
                ;; a<=b, so c<b (b<=c is impossible due to above test)
-               (if (less? c a) (list c a b) (list a c b))))))]
-      [else (let (;; list -> mlist
-                  [mlst (mcons (car lst) null)])
-              (let loop ([last mlst] [lst (cdr lst)])
+               (if (<? c a) (list c a b) (list a c b))))))]
+      [else (let ([vec (make-vector (+ n (/ n 2)))])
+              ;; list -> vector
+              (let loop ([i 0] [lst lst])
                 (when (pair? lst)
-                  (let ([new (mcons (car lst) null)])
-                    (set-mcdr! last new)
-                    (loop new (cdr lst)))))
-              ;; mlist -> list
-              (let loop ([r (if getkey
-                              (sort-internal *less? mlst n getkey)
-                              (sort-internal *less? mlst n))])
-                (if (null? r) r (cons (mcar r) (loop (mcdr r))))))])))
+                  (vector-set! vec i (car lst))
+                  (loop (add1 i) (cdr lst))))
+              ;; sort
+              (if getkey
+                (sort-internal *<? vec n getkey)
+                (sort-internal *<? vec n))
+              ;; vector -> list
+              (let loop ([i n] [r '()])
+                (let ([i (sub1 i)])
+                  (if (< i 0) r (loop i (cons (vector-ref vec i) r))))))])))
 
 ;; Finally, this is the provided `sort' value
 (case-lambda
-  [(lst less?) (sort-body lst less? #f #f #f)]
-  [(lst less? getkey)
+  [(lst <?) (sort-body lst <? #f #f #f)]
+  [(lst <? getkey)
    (if (and getkey (not (eq? values getkey)))
-     (sort lst less? getkey #f) (sort lst less?))]
-  [(lst less? getkey cache-keys?)
+     (sort lst <? getkey #f) (sort lst <?))]
+  [(lst <? getkey cache-keys?)
    (if (and getkey (not (eq? values getkey)))
-     (sort-body lst less? #t getkey cache-keys?) (sort lst less?))])
+     (sort-body lst <? #t getkey cache-keys?) (sort lst <?))])
 
 )))